home *** CD-ROM | disk | FTP | other *** search
/ Business Shareware / Business Shareware.iso / start / database / lib194 / files.prg < prev    next >
Encoding:
Text File  |  1993-02-08  |  78.6 KB  |  2,107 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: FILES.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are file processing routines. To see how to use this 
  6. *--             library file, see: README.TXT.
  7. *-------------------------------------------------------------------------------
  8.  
  9. PROCEDURE AllTags
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Susan Perschke (SPECDATA) and Michael Liczbanski (LMIKE)
  12. *-- Date........: 01/03/1992
  13. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  14. *--               so they can change the current tag ... This was gotten to me
  15. *--               by Steve (LTI), from "Data Based Advisor", December, 1991.
  16. *-- Written for.: dBASE IV, 1.1
  17. *-- Rev. History: 12/15/1991 - original procedure.
  18. *--               01/03/1992 - Ken Mayer -- added shadow ...
  19. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  20. *-- Called by...: Any
  21. *-- Usage.......: DO AllTags WITH nULRow, nULCol
  22. *-- Example.....: ON KEY LABEL F8 DO ALLTAGS WITH 02,60
  23. *-- Returns.....: None
  24. *-- Parameters..: nULRow -- Starting Row for Popup
  25. *--               nULCol -- Starting Column for Popup
  26. *-------------------------------------------------------------------------------
  27.  
  28.     parameters nULRow, nULCol
  29.     private nBar, cPrompt, nBRRow, nBRCol
  30.     
  31.     *-- Disable left/right arrow keys to prevent an accidental exit
  32.     on key label leftarrow  ?? chr(7)
  33.     on key label rightarrow ?? chr(7)
  34.     
  35.     *-- Save current screen
  36.     save screen to sTag
  37.     activate screen
  38.     
  39.     *-- define the popup
  40.     define popup pTag from nULRow, nULCol;
  41.        message " Press ENTER to select new index order...ESC to exit..."
  42.     nBar = 1                        && first bar
  43.     cPrompt    = "-No Index-"       &&  will always be this
  44.     
  45.     *-- loop to get the rest of 'em ...
  46.     do while "" <> cPrompt          && loop until no more tags
  47.         define bar nBar of pTag prompt (cPrompt)
  48.         cPrompt = tag(nBar)
  49.         nBar = nBar + 1
  50.     enddo
  51.     
  52.     on selection popup pTag deactivate popup
  53.     
  54.     *-- process shadow
  55.     nBRRow = nULRow+(nBar-1)+1 && bottom right for shadow (1 for t/b of pop)
  56.     nBRCol = nULCol+11         && bottom right for shadow (2 for sides,
  57.                    &&   +9 for tagnames)
  58.     do shadow with nULRow,nULCol,nBRRow,nBRCol
  59.     
  60.     *-- do it
  61.     activate popup pTag
  62.     
  63.     *-- Assign a null string to cPrompt if "No Index" selected
  64.     cPrompt = iif(bar() = 1, "",prompt())
  65.     
  66.     *-- Don't change index order if ESC pressed
  67.     if bar() <> 0
  68.        set order to (cPrompt)
  69.     endif
  70.     
  71.     *-- cleanup
  72.     release popup pTag
  73.     restore screen from sTag
  74.     release screen sTag
  75.     
  76.     *-- Enable left/right arrow keys
  77.     on key label leftarrow
  78.     on key label rightarrow
  79.  
  80. RETURN
  81. *-- EoP: AllTags
  82.  
  83. PROCEDURE MakeTagFl
  84. *-------------------------------------------------------------------------------
  85. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  86. *-- Date........: 04/15/1992
  87. *-- Notes.......: Build a .dbf file from scratch, without using CREATE FROM.
  88. *--               The file built has three fields, TAGS1, TAGS2 and TAGS3,
  89. *--               each character-type and 254 bytes wide.
  90. *-- Written for.: dBASE IV, 1.1
  91. *-- Rev. History: Broken out of other code and date-writing added
  92. *--               by Jay Parsons, 4/15/1992
  93. *--             : Originally from the program PRGCREAT.ZIP
  94. *-- Called by...: Any
  95. *-- Usage.......: do MakeTagFl WITH "<cFname>"
  96. *-- Example.....: do MakeTagFl WITH "Tags"
  97. *-- Returns.....: None
  98. *-- Parameters..: cFname, name of the .dbf to create
  99. *-- Side effects: Creates a .dbf and overwrites any existing one of same name
  100. *--             : Disables external setting of PRINTER
  101. *-------------------------------------------------------------------------------
  102.     parameters cFname
  103.     private cName
  104.     cName = cFname
  105.     if .not. "." $ cName
  106.        cName = cName + ".DBF"
  107.     endif
  108.     set printer to file ( cName )
  109.     set printer on
  110.     ??? "{3}"
  111.     ??? chr( year( date() - 1900 ) )
  112.     ??? chr( month( date() ) )
  113.     ??? chr( day( date() ) )
  114.     ??? "{0}{0}{0}{0}{129}{0}{251}{2}{0}{0}{0}{0}"
  115.     ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{201}{0}"
  116.     ??? "{84}{65}{71}{83}{49}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags1
  117.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  118.     ??? "{84}{65}{71}{83}{50}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags2
  119.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  120.     ??? "{84}{65}{71}{83}{51}{0}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}" && Tags3
  121.     ??? "{254}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  122.     ??? "{13}{26}"
  123.     set printer off
  124.     set printer to
  125.  
  126. RETURN
  127. *-- EoP: MakeTagFl
  128.  
  129. PROCEDURE RedoTags
  130. *-------------------------------------------------------------------------------
  131. *-- Programmer..: David Love (CIS: 70153,2433)
  132. *-- Date........: 04/18/1992
  133. *-- Notes.......: This routine is a "generic" MDX cleanup routine. It is useful
  134. *--               for handling "bloated" MDX files -- ones that have been around
  135. *--               awhile (they tend to be larger than necessary). This routine
  136. *--               will store the tag keys in an array, delete the tags, and then
  137. *--               rebuild the MDX file from scratch, keeping all tag names and
  138. *--               keys, and the MDX SHOULD be smaller.
  139. *--             : Will act on the dbf's production mdx (ie. same name as dbf)
  140. *-- Written for.: dBASE IV, 1.5
  141. *-- Rev. History: 01/20/1992 - original function for dBASE IV Ver. 1.1.
  142. *--               04/18/1992 - David Love - adapted for use with beta version
  143. *--               of dBASE IV, version 1.5.
  144. *--               (TAGCOUNT(), FOR(), DESCENDING(), UNIQUE() are 1.5 functions)
  145. *-- Calls.......: None
  146. *-- Called by...: Any
  147. *-- Usage.......: do RedoTags with "<cDBF>"
  148. *-- Example.....: do RedoTags with "Referral"
  149. *-- Returns.....: None
  150. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  151. *-------------------------------------------------------------------------------
  152.  
  153.     parameter cDBF
  154.     
  155.     use (cDBF) excl
  156.     
  157.     *-- First, figure out how many tags exist
  158.  
  159.     private nMaxTags
  160.     nMaxTags = tagcount( cDBF,1 )
  161.     
  162.     *-- only perform routine if an index tag exists
  163.     if nMaxTags > 0
  164.       private nTags, mkey, mtag
  165.     
  166.       *-- store the keys and tags to an array
  167.       declare aTags[nMaxTags,5]
  168.        nTags = 1
  169.       do while nTags <= nMaxTags
  170.     store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  171.     store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  172.     store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  173.     store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  174.     store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  175.         nTags = nTags + 1
  176.       enddo
  177.     
  178.        *-- now, delete the tags   
  179.        do while "" # tag( (cDBF),1)
  180.      delete tag tag( (cDBF),1)
  181.        enddo
  182.       
  183.        *-- rebuild the MDX, tag by tag ...
  184.        nTags = 1
  185.       do while nTags <= nMaxTags
  186.     mkey = aTags[nTags,1]+iif(""#aTags[nTags,3]," for "+aTags[nTags,3],"") ;
  187.       + iif(aTags[nTags,4]," DESCENDING","") ;
  188.       + iif(aTags[nTags,5]," UNIQUE","")
  189.          mtag = aTags[nTags,2]
  190.     index on &mkey. tag &mtag.
  191.          nTags = nTags + 1
  192.       enddo
  193.     
  194.        *-- release the array ...
  195.       release aTags
  196.     
  197.     endif  && check for tags ...
  198.     use    && close database
  199.     
  200. RETURN
  201. *-- EoP: RedoTags
  202.  
  203. PROCEDURE AutoRedo
  204. *------------------------------------------------------------------------------
  205. *-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
  206. *-- Date........: 03/06/1992
  207. *-- Notes.......: Displays a popup to choose a DBF from the current directory
  208. *--               to re-build its MDX file
  209. *-- Written for.: dBASE IV, 1.1
  210. *-- Rev. History: 03/04/1992 - original procedure.
  211. *--               03/06/1992 -- Ken Mayer added color parameter,
  212. *--                shadow to popup, and erase DBFS.DBF datafile at end.
  213. *-- Calls.......: LISTDBFS             Procedure in FILES.PRG
  214. *--               REDOTAGS             Procedure in FILES.PRG
  215. *--               CENTER               Procedure in PROC.PRG
  216. *--               YESNO2()             Function in PROC.PRG
  217. *--               SHADOW               Procedure in PROC.PRG       
  218. *--               EXTRCLR()            Function in PROC.PRG
  219. *-- Called by...: Any
  220. *-- Usage.......: do AutoRedo with nXTL,nYTL,nXBR,nYBR,cColor
  221. *-- Example.....: do AutoRedo with 5,34,15,47,"rg+/gb,w+/n,rg+/gb"
  222. *-- Returns.....: None
  223. *-- Parameters..: None
  224. *------------------------------------------------------------------------------
  225.  
  226.     parameters nXTL, nYTL, nXBR, nYBR, cColor
  227.     
  228.     *-- Save Environment
  229.     cTalk = set("talk")
  230.     cStat = set("status")
  231.     cCloc = set("clock")
  232.     cScor = set("scoreboard")
  233.     cSafe = set("safety")
  234.     
  235.     *-- Set Environment
  236.     set stat off
  237.     set talk off
  238.     set cloc off
  239.     set scor off
  240.     set safe off
  241.     
  242.     *-- Full Screen Window for screen restoration when finished
  243.     define window wCoverScr from 0,0 to 23,79 none
  244.     activate window wCoverScr
  245.     clear
  246.     
  247.     *-- Make a Data File of the Current Directory
  248.     do center with 10,80,extrclr('&cColor'),;
  249.         '... Making Data File from Current Directory ...'
  250.     do ListDBFs
  251.     
  252.     use DBFS
  253.     index on DBFS->DBF tag IORDER
  254.     
  255.     *-- Define and access the popup of DataFiles
  256.     activate screen
  257.     define popup uDbfList from nXTL,nYTL to nXBR,nYBR prompt field DBFS->DBF
  258.     on selection popup uDbfList deactivate popup
  259.     
  260.     *-- Execute loop for multiple re-indexes
  261.     clear
  262.     lLoop = .t.
  263.     do while lLoop
  264.         do shadow with nXTL,nYTL,nXBR,nYBR
  265.        activate popup uDbfList
  266.         clear  && get rid of shadow
  267.         
  268.        *--  Record the prompt() and remove '.dbf' so it works with Redotag
  269.        cDataFile = substr(prompt(),1,len(trim(prompt()))-4)
  270.     
  271.        *-- Verify the MDX exists
  272.        if file(cDataFile+'.mdx')
  273.           do redotags with cDataFile
  274.        else
  275.           do center with 10,80,extrclr("&cColor"),;
  276.         '... Production MDX file not found for file '+cDataFile
  277.           n = inkey(0)
  278.           clear
  279.        endif
  280.     
  281.        *-- Determine if the user wants to re-build another
  282.        if YesNo2(.t.,"CC","",;
  283.           "Do you wish to reindex another file?","","&cColor")
  284.           use DBFS order IORDER
  285.        else
  286.           lLoop = .f.
  287.        endif
  288.     
  289.     enddo
  290.     
  291.     *-- Restore environment
  292.     use DBFS
  293.     delete tag IORDER
  294.     use
  295.     erase DBFS.DBF
  296.     release popup uDbfList
  297.     deactivate window wCoverScr
  298.     release window wCoverScr
  299.     set stat &cStat
  300.     set talk &cTalk
  301.     set cloc &cCloc
  302.     set scor &cScor
  303.     set safe &cSafe
  304.     
  305. RETURN
  306. *-- EoP:  AutoRedo
  307.  
  308. PROCEDURE PrntTags
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: David Love (CIS: 70153,2433)
  311. *-- Date........: 04/18/1992
  312. *-- Notes.......: This routine is a "quick and not-so-dirty" method of printing
  313. *--               the tag and key expressions for a dbf's production mdx file.
  314. *--               It obviates the need for DISP/LIST STAT TO PRINT (or DISP STAT
  315. *--               followed by SHIFT+PrtScr).
  316. *--               This code is modified from the procedure RedoTags.prg,
  317. *--               previously posted on the BORBBS.
  318. *--             : The proc will print the full key expression, including
  319. *--               FOR/DESCENDING/UNIQUE options, if present.
  320. *-- Written for.: dBASE IV, 1.1
  321. *-- Rev. History: 01/31/1992 - original procedure written for dBASE IV, Ver. 1.1
  322. *--               04/18/1992 - David Love - revised for version 1.5
  323. *-- Calls.......: None
  324. *-- Called by...: Any
  325. *-- Usage.......: do PrntTags with "<cDBF>"
  326. *-- Example.....: do PrntTags with "Referral"
  327. *-- Returns.....: None
  328. *-- Parameters..: cDBF = Name of DATABASE file, no extension necessary.
  329. *-------------------------------------------------------------------------------
  330.  
  331.     parameter cDBF
  332.     
  333.     use (cDBF)
  334.     
  335.     *-- First, figure out how many tags exist
  336.  
  337.     private nMaxTags
  338.     nMaxTags = tagcount( cDBF,1 )
  339.     
  340.     *-- only perform routine if an index tag exists
  341.     if nMaxTags > 0
  342.       private nTags, mkey, mtag
  343.     
  344.       *-- store the keys and tags to an array
  345.       declare aTags[nMaxTags,5]
  346.        nTags = 1
  347.       do while nTags <= nMaxTags
  348.     store key( (cDBF),nTags) to aTags[nTags,1]        && grab the key
  349.     store tag( (cDBF),nTags) to aTags[nTags,2]        && grab the tagname
  350.     store for( (cDBF),nTags) to aTags[nTags,3]        && grab the for clause
  351.     store descending( (cDBF),nTags) to aTags[nTags,4] && .t. if descending
  352.     store unique( (cDBF),nTags) to aTags[nTags,5]     && .t. if unique
  353.          nTags = nTags + 1
  354.       enddo
  355.     
  356.       *-- print each tag with it's key expression
  357.       private cTalk
  358.       cTalk = set("TALK")
  359.       set talk off
  360.       set printer on
  361.       ?? "DATABASE: "+cDBF AT 0
  362.       ?
  363.       ?? "TAG" at 0
  364.       ?? "KEY EXPRESSION" AT 12
  365.       ?
  366.       nTags = 1
  367.       do while nTags <= nMaxTags
  368.     ?? aTags[nTags,2] AT 0
  369.     ?? aTags[nTags,1] + ;
  370.       iif(""#aTags[nTags,3]," FOR "+aTags[nTags,3],"") + ;
  371.       iif(aTags[nTags,4]," DESCENDING","") + ;
  372.       iif(aTags[nTags,5]," UNIQUE","") AT 12
  373.     ?
  374.     nTags = nTags + 1
  375.       enddo
  376.       ?
  377.       set printer off
  378.       set talk &cTalk.
  379.  
  380.       *-- release the array ...
  381.       release aTags
  382.     
  383.     endif  && check for tags ...
  384.     use    && close database
  385.     
  386. RETURN
  387. *-- EoP: PrntTags
  388.  
  389. PROCEDURE ListDBFs
  390. *-------------------------------------------------------------------------------
  391. *-- Programmer..: David Love (70153,2433)
  392. *-- Date........: 01/31/1992
  393. *-- Notes.......: This procedure will create a list of the database (.dbf) files
  394. *--               in the current directory.  It will create a database file
  395. *--               named Dbfs.dbf which exists of one 12-character field--Dbf.
  396. *--               It will also create a text file, Dbfs.txt, through the
  397. *--               LIST FILES to FILE command.  Then it will append records
  398. *--               to the Dbfs.dbf file and erase the Dbfs.txt file.
  399. *--             : This Dbfs.dbf file can be SCANned, or used in a POPUP PROMPT
  400. *--               FIELD command, or in any way that you can imagine.
  401. *--             : The file 'Dbfs.dbf' will not be included in the Dbfs.dbf file.
  402. *-- WARNING===> : If your application includes a file with the name of
  403. *--               'Dbfs.dbf', it will be overwritten with the file created
  404. *--                by this procedure.
  405. *-- Written for.: dBASE IV, 1.1
  406. *-- Rev. History: None
  407. *-- Calls.......: None
  408. *-- Called by...: Any
  409. *-- Usage.......: do ListDBFs
  410. *-- Example.....: do ListDBFs
  411. *-- Returns.....: None
  412. *-- Parameters..: None
  413. *-------------------------------------------------------------------------------
  414.  
  415.    private cConsole
  416.    *-- Write the directory of dbf files to a text file (Dbfs.txt)
  417.    *-- First, erase the file if it exists
  418.    if file("Dbfs.txt")
  419.      erase dbfs.txt
  420.    endif
  421.  
  422.    *-- And, erase the dbfs.dbf file if it exists (so won't be included
  423.    *-- in the list)
  424.    if file("Dbfs.dbf")
  425.      erase Dbfs.dbf
  426.    endif
  427.  
  428.    *-- Now, write the dbfs.txt file
  429.    cConsole = set("CONSOLE")
  430.    set console off
  431.    list files to file dbfs.txt
  432.    set console &cConsole.
  433.  
  434.    *-- Then, create the file DBFS.DBF
  435.     *-- Acknowledgement..: Bowen Moursund for the code that creates Dbfs.dbf
  436.     *--                    (Download PRGCREAT.ZIP from BORBBS for more info.)
  437.    set printer to file DBFS.DBF
  438.    set printer on
  439.    ??? "{3}{92}{2}{1}{0}{0}{0}{0}{65}{0}{13}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  440.    "{0}{0}{0}{0}{0}{0}{0}{0}{89}{0}{68}{66}{70}{0}{0}{0}{0}{0}{0}{0}{0}{67}{3}"+;
  441.    "{0}{44}{85}{12}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{13}{26}"
  442.    set printer to
  443.    set printer off
  444.  
  445.    *-- Now, append dbfs.txt to dbfs.dbf if the record is a dbf listing.
  446.    use Dbfs
  447.    append from Dbfs.txt for ".DBF" $ Dbf type sdf
  448.  
  449.    use    && can remove this command if you want
  450.  
  451.    erase Dbfs.txt            && don't need it anymore
  452.  
  453. RETURN
  454. *--EOP: ListDBFs
  455.  
  456. FUNCTION Recompile
  457. *-------------------------------------------------------------------------------
  458. *-- Programmer..: Jay Parsons (CIS: 71600,340)
  459. *--             : Adapted from Compall.prg and Compall2.prg, by James Thomas.
  460. *-- Date........: 04/16/1992
  461. *-- Notes.......: Recompiles all dBASE source-code files.  Takes three
  462. *--             : optional parameters:
  463. *--             :    Directory to recompile.  Default is current directory.
  464. *--             :    Skeleton to recompile.  Default is all of .PRG, .LBG,
  465. *--             :       .FRG, .PRS, .FMT, .QBE and .UPD files.  If a skeleton
  466. *--             :       is provided that matches files that are not dBASE
  467. *--             :       source-code files, compiler errors will occur and,
  468. *--             :       in the absence of external error handling, see below,
  469. *--             :       suspend processing.
  470. *--             :    "Runtime" or any characters starting with "R" or "r" to
  471. *--             :       direct the compilation be with the "RUNTIME" option.
  472. *--             : Does not recompile a file if a file of the same root name,
  473. *--             : an .??O extension and a later timestamp resides in the
  474. *--             : directory.
  475. *--             : Renames compilations of FMT, FRG, LBG and QBO files to ??O.
  476. *--             : Returns .T. if successful, or .F.
  477. *--             :
  478. *--             : Listing of compilation errors requires SET ALTERNATE TO,
  479. *--             : and trapping such errors as passing the name of a file
  480. *--             : that does not contain dBASE source code to the COMPILE
  481. *--             : command requires an ON ERROR trap.  These are omitted here
  482. *--             : due to lack of ways to prevent the function from changing
  483. *--             : these settings externally.  Lines needed to have any
  484. *--             : compilation errors print to the alternate file are included
  485. *--             : as comments.
  486. *--             :
  487. *-- Written for.: dBASE IV Version 1.5.
  488. *--             : Adaptation to a prior release may require changing the
  489. *--             : way parameters are handled, and also rewriting the lines
  490. *--             : that use fdate() and ftime() to read timestamps.
  491. *-- Rev. History: 04/07/1992 - original function.
  492. *--             : 04/13/1992 - additional environment settings.
  493. *--             : 04/16/1992 - aliases added thanks to BOWEN.
  494. *--             : 06-10-1992 - a few minor bug fixes
  495. *-- Calls       : Makestru()            FUNCTION in FILES.PRG
  496. *-- Called by...: Any
  497. *-- Usage.......: Recompile ( [<cDir>] [,<cSkel> [,"R"]] )
  498. *-- Example.....: ? Recompile ( "\dBASE\Myprogs", "*.??G" )
  499. *-- Parameters..: cDir, a DOS directory name ( and path if needed )
  500. *--             : cSkel, skeleton using wildcards for files to compile
  501. *--             : cRun, "R" or "r" if compilation is for Runtime
  502. *-- Side effects: Creates compiled .??O files, overwriting any of the same
  503. *--             : root names that may exist.
  504. *-------------------------------------------------------------------------------
  505.  
  506.    parameters cDirectry, cSkeleton, cRun
  507.    private cCons, cAlias, cAlt, cDir, cSafety, cTempfile,;
  508.        cSrcfile, cObjfile, cString1, cString2, cRunopt
  509.  
  510.    * preserve environment
  511.    cCons = set( "CONSOLE" )
  512.    SET CONSOLE OFF
  513.    cAlias = alias()
  514.    cAlt = set( "ALTERNATE" )
  515.    SET ALTERNATE OFF
  516.    cDir = set( "DIRECTORY" )
  517.    IF type( "cDirectry" ) = "C" .AND. "" # cDirectry
  518.       SET DIRECTORY TO &cDirectry
  519.    ENDIF
  520.    cSafety = set( "SAFETY" )
  521.    SET SAFETY OFF
  522.    SELECT select()
  523.  
  524.    * make temporary structure file and fill in the DOS DIR listing structure
  525.    cTempfile = Makestru()
  526.    USE ( cTempfile ) ALIAS cTempfile
  527.    APPEND BLANK
  528.    REPLACE FIELD_NAME WITH "FILENAME", FIELD_TYPE WITH "C", FIELD_LEN WITH 9, ;
  529.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  530.    APPEND BLANK
  531.    REPLACE FIELD_NAME WITH "EXT", FIELD_TYPE WITH "C", FIELD_LEN WITH 4, ;
  532.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  533.    APPEND BLANK
  534.    REPLACE FIELD_NAME WITH "FLENGTH", FIELD_TYPE WITH "C", FIELD_LEN WITH 10, ;
  535.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  536.    APPEND BLANK
  537.    REPLACE FIELD_NAME WITH "TIMESTAMP", FIELD_TYPE WITH "C", FIELD_LEN WITH 16, ;
  538.        FIELD_DEC WITH 0, FIELD_IDX WITH "N"
  539.  
  540.    * make .dbf for source file names, reset and return if error occurs
  541.    cSrcfile = cTempfile
  542.    DO WHILE file ( cSrcfile + ".DBF" )
  543.       cSrcfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  544.    ENDDO
  545.    CREATE ( cSrcfile ) FROM  ( cTempfile )
  546.    USE ( cSrcfile ) alias cSrcfile
  547.  
  548.    IF "" = alias()
  549.      ERASE ( cTempfile +".DBF" )
  550.      SET DIRECTORY TO &cDir
  551.      SET ALTERNATE &cAlt
  552.      IF "" # cAlias
  553.     SELECT ( cAlias )
  554.      ENDIF
  555.      SET CONSOLE &cCons
  556.      RETURN .F.
  557.    ENDIF
  558.  
  559.    * and for object file names
  560.    SELECT select()
  561.    USE ( cTempfile ) ALIAS cTempfile
  562.    GO 1
  563.    REPLACE FIELD_IDX WITH "Y"
  564.    cObjfile = cSrcfile
  565.    DO WHILE file ( cObjfile + ".DBF"  )
  566.       cObjfile  = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  567.    ENDDO
  568.    CREATE ( cObjfile ) FROM (cTempfile)
  569.    use ( cObjfile ) alias cObjfile order filename
  570.    IF "" = alias()
  571.       ERASE ( cTempfile + ".DBF" )
  572.       SELECT cSrcfile
  573.       USE
  574.       ERASE ( cSrcfile + ".DBF" )
  575.       SET DIRECTORY TO &cDir
  576.       SET ALTERNATE &cAlt
  577.       IF "" # cAlias
  578.      SELECT  ( cAlias )
  579.       ENDIF
  580.       SET CONSOLE &cCons
  581.       RETURN .F.
  582.    ENDIF
  583.  
  584.    * reuse name of cTempfile as SDF; DIR names of source files to it and append
  585.    cString1 = cTempfile + ".DBF"
  586.  
  587.    RUN dir *.* > &cString1
  588.    SELECT  cSrcfile
  589.    APPEND FROM ( cString1 ) TYPE SDF
  590.  
  591.    * delete directory entries not for source files of desired name or type
  592.    IF type("cSkeleton") = "C" .AND. "" # cSkeleton
  593.       DELETE ALL FOR .NOT. like( upper( cSkeleton ), trim( Filename ) +"." ;
  594.         + trim( Ext ) )
  595.    ELSE
  596.       DELETE ALL FOR .NOT. Ext $ "PRG LBG FRG PRS FMT QBE UPD "
  597.    ENDIF
  598.    PACK
  599.  
  600.    * reuse again for .??O files
  601.    RUN dir *.??o > &cString1
  602.    SELECT cObjfile
  603.    APPEND FROM ( cString1 ) TYPE SDF
  604.    DELETE ALL FOR left( Filename, 1 ) = " " .OR. right( Ext, 2 ) # "O "
  605.    PACK
  606.    ERASE ( cString1 )
  607.  
  608.    * assemble Runtime option
  609.    cRunopt = iif( type( "cRun" ) = "C" .AND. "" # cRun ;
  610.        .AND. left( cRun, 1 ) $ "Rr", " RUNTIME", "" )
  611.  
  612.    * now compile all the files that need it
  613.    SELECT cSrcfile
  614.    SCAN
  615.       cString1 = trim( Filename ) + "." + trim( Ext )
  616.       *   Is there an object file of this name?
  617.       IF Seek( Filename, "cObjfile" )
  618.      cString2 = trim( cObjfile->Filename ) + "." + trim( cObjfile->Ext )
  619.      cString2 = dtos( fdate( cString2 ) ) + ftime( cString2 )
  620.      *   then check timestamps and skip it if already compiled
  621.      IF dtos( fdate( cString1 ) ) + ftime( cString1 ) < cString2
  622.         LOOP
  623.      ENDIF
  624.       ENDIF
  625.       *   compile it otherwise, listing errors if enabled
  626.       cString2 = cString1 + cRunopt
  627.       * SET ALTERNATE ON
  628.       * ? "Compiling " + cString2
  629.       COMPILE &cString2
  630.       * ?
  631.       * SET ALTERNATE OFF
  632.       *   and rename object files that should not be .DBOs
  633.       IF Ext $ "FMT FRG LBG QBE "
  634.      cString2 = stuff( cString1, len( cString1 ), 1, "O" )
  635.      IF file( cString2 )
  636.         ERASE ( cString2 )
  637.      ENDIF
  638.      cString1 = trim( Filename ) + ".DBO"
  639.      RENAME ( cString1 ) TO ( cString2 )
  640.       ENDIF
  641.    ENDSCAN
  642.  
  643.    *  Clean up
  644.    USE
  645.    ERASE ( cSrcfile + ".DBF" )
  646.    SELECT cObjfile
  647.    USE
  648.    ERASE ( cObjfile + ".DBF" )
  649.    ERASE ( cObjfile + ".MDX" )
  650.    SET SAFETY &cSafety
  651.    SET DIRECTORY TO &cDir
  652.    SET ALTERNATE &cAlt
  653.    IF "" # cAlias
  654.      SELECT ( cAlias )
  655.    ENDIF
  656.    SET CONSOLE &cCons
  657.  
  658. RETURN .T.
  659. *-- Eof() Recompile
  660.  
  661. PROCEDURE Makedbf
  662. *-------------------------------------------------------------------------------
  663. *-- Programmer..: Jay Parsons (CIS: 71600,340).
  664. *-- Date........: 04/26/1992
  665. *-- Notes.......: Makes an empty dBASE .dbf file
  666. *-- Written for.: dBASE IV, 1.1, 1.5
  667. *-- Rev. History: None
  668. *-- Calls       : Tempname()          function in FILES.PRG
  669. *-- Called by...: Any
  670. *-- Usage.......: DO MakeDbf WITH <cFilename>, <cStrufile>, <cArray>
  671. *-- Example.....: DO MakeDbf WITH Customers, cCustfields
  672. *-- Parameters..: cFilename - filename ( without extension ) of the .dbf to be
  673. *--               created.
  674. *--               cStrufile - name ( without extension ) of a STRUC EXTE .dbf
  675. *--               cArray - name of the array holding field information for the
  676. *--               .dbf.  The array must be dimensioned [ F, 5 ] where F is the
  677. *--               number of fields.  Each row must hold data for one field:
  678. *--                     [ F, 1 ]  field name, character
  679. *--                     [ F, 2 ]  field type, character from set "CDFLMN"
  680. *--                     [ F, 3 ]  field length, numeric.  If field type is
  681. *--                                 D, L, or M, will be ignored
  682. *--                     [ F, 4 ]  field decimals, numeric. optional if 0.
  683. *--                     [ F, 5 ]  field is mdx tag, char $ "YN", optional if N
  684. *-------------------------------------------------------------------------------
  685.   parameters cFname, cSname, aAname
  686.   private nX,cF1,cF2,cF3,cF4,cF5,cStrufile,cFtype
  687.   cF1 = aAname + "[nX,1]"
  688.   cF2 = aAname + "[nX,2]"
  689.   cF3 = aAname + "[nX,3]"
  690.   cF4 = aAname + "[nX,4]"
  691.   cF5 = aAname + "[nX,5]"
  692.   select select()
  693.   use ( cSname ) ALIAS cSname
  694.   zap
  695.   nX = 1
  696.   do while type( cF1 ) # "U"
  697.     cFtype = &cF2
  698.     append blank
  699.     replace Field_name with &cF1, Field_type with cFtype
  700.     do case
  701.       case cFtype = "D"
  702.     replace Field_len with 8
  703.       case cFtype = "M"
  704.     replace Field_len with 10
  705.       case cFtype = "L"
  706.     replace Field_len with 1
  707.       otherwise
  708.     replace Field_len with &cF3
  709.     endcase
  710.     if type( cF4 ) = "N" .and. cFtype $ "FN"
  711.     replace Field_dec with &cF4
  712.     else
  713.     replace Field_dec with 0
  714.     endif
  715.     if type( cF5 ) # "U" .and. cFtype $ "CDFN" .and. &cF5 = "Y"
  716.       replace Field_idx with "Y"
  717.     else
  718.       replace Field_idx with "N"
  719.     endif
  720.     nX = nX + 1
  721.   enddo
  722.   use
  723.   create ( cFname ) FROM ( cSname )
  724.  
  725. RETURN
  726. *-- EoP: Makedbf
  727.  
  728. PROCEDURE MakeDBF2
  729. *-------------------------------------------------------------------------------
  730. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  731. *-- Date........: 05-27-1992
  732. *-- Notes.......: Creates an empty DBF file of the structure specified in
  733. *--               the array aMakeDBF[], which must be declared and initialized
  734. *--               with the proper values before calling this procedure.
  735. *--               The array must be declared as aMakeDBF[n,5], where n is
  736. *--               the number of fields in the DBF to be created. The columns
  737. *--               of the array correspond to the fields of a structure extended
  738. *--               file, and must be initialized to the appropriate values,
  739. *--               before calling this procedure, one row for each field.
  740. *--
  741. *--               Structure of a structure extended file:
  742. *--               Field    Type  Len  Dec
  743. *--               -----------------------
  744. *--               FIELD_NAME  C   10    0
  745. *--               FIELD_TYPE  C    1    0
  746. *--               FIELD_LEN   N    3    0
  747. *--               FIELD_DEC   N    3    0
  748. *--               FIELD_IDX   C    1    0
  749. *--
  750. *--               aMakeDBF[n,1] = Field name: 10 or less characters
  751. *--               aMakeDBF[n,2] = Field type: 1 character
  752. *--                               "C" = character
  753. *--                               "N" = numeric
  754. *--                               "F" = float
  755. *--                               "D" = date
  756. *--                               "L" = logical
  757. *--                               "M" = memo
  758. *--               aMakeDBF[n,3] = Field length: numeric
  759. *--                               "C" = 1 - 254
  760. *--                               "N","F" = use dBASE guidelines
  761. *--                               "D" = 8
  762. *--                               "L" = 1
  763. *--                               "M" = 10
  764. *--               aMakeDBF[n,4] = Decimal places: numeric
  765. *--                               0 for non numeric fields
  766. *--               aMakeDBF[n,5] = MDX flag: 1 char, "Y" or "N"
  767. *--
  768. *-- Written for.: dBASE IV, 1.5
  769. *-- Rev. History: None
  770. *-- Calls.......: None
  771. *-- Called by...: Any
  772. *-- Usage.......: do MakeDBF with <cDBFpath>,<cStruPath>
  773. *-- Example.....: cStruPath = MakeStru2(.f.)
  774. *--               declare aMakeDBF[1,5]
  775. *--               aMakeDBF[1,1] = "FIELD1"
  776. *--               aMakeDBF[1,2] = "C"
  777. *--               aMakeDBF[1,3] = 20
  778. *--               aMakeDBF[1,4] = 0
  779. *--               aMakeDBF[1,5] = "N"
  780. *--               do MakeDBF2 with "foo", cStruPath
  781. *--               erase (cStruPath+".dbf")
  782. *--               release aMakeDBF
  783. *-- Returns.....: none
  784. *-- Parameters..: cDBFpath = the [path]filename of the DBF to be created.
  785. *--               cStruPath = the [path]filename of an empty structure extended
  786. *--                           file.
  787. *-------------------------------------------------------------------------------
  788.  
  789.    parameters cDBFpath,cStruPath
  790.    if pcount() = 2  && we need 2 parms
  791.       private all except aMakeDB*
  792.       if type("aMakeDBF[1,1]") = "C"  && check array validity
  793.      cAlias = alias()
  794.      select select()
  795.      use (cStruPath)
  796.      append from array aMakeDBF
  797.      use
  798.      create (cDBFpath) from (cStruPath)
  799.      use
  800.      if "" # cAlias
  801.         select (cAlias)
  802.      endif
  803.       endif
  804.    endif
  805.  
  806. RETURN
  807. *-- EoP: MakeDBF2
  808.  
  809. FUNCTION Makestru
  810. *-------------------------------------------------------------------------------
  811. *-- Programmer..: Martin Leon (Hman), formerly sysop of A-T BBS
  812. *--             : Revised by Jay Parsons, (CIS: 71600,340).
  813. *-- Date........: 04/24/1992
  814. *-- Notes.......: Makes an empty dBASE STRUCTURE EXTENDED file and returns
  815. *--             : its root name
  816. *-- Written for.: dBASE IV v1.5
  817. *-- Rev. History: 06/12/1991 - original function.
  818. *--             : Changed to take no parameter, return filename, 4-7-1992.
  819. *--             : Code added to preserve catalog status and name, 4-10-1992.
  820. *--             : Use of Tempname() added 4-24-92.
  821. *--             : set("safety") check, minor mods, 05-28-1992, Bowen Moursund
  822. *-- Calls       : Tempname()          Function in FILES.PRG
  823. *-- Called by...: Any
  824. *-- Usage.......: Makestru()
  825. *-- Example.....: Tempfile = Makestru()
  826. *-- Returns.....: Name of file created
  827. *-- Parameters..: None
  828. *-------------------------------------------------------------------------------
  829.  
  830.    private all
  831.    lTitleOn = ( set("TITLE") = "ON" )
  832.    lSafeOn = ( set("SAFETY") = "ON" )
  833.    lCatOff = ( set("CATALOG") = "OFF" )
  834.    cAlias = alias()
  835.    cTmpCat = TempName("cat") + ".CAT"
  836.    set title off
  837.    set safety off
  838.    cCatalog = catalog()
  839.    set catalog to (cTmpCat)
  840.    set catalog to &cCatalog.
  841.    cStruName = TempName("dbf")
  842.    select select()
  843.    use (cTmpCat) nosave
  844.    copy to (cStruName) structure extended
  845.    use (cStruName) exclusive
  846.    zap
  847.    use
  848.    if lTitleOn
  849.       set title on
  850.    endif
  851.    if lSafeOn
  852.       set safety on
  853.    endif
  854.    if lCatOff
  855.       set catalog off
  856.    endif
  857.    if "" # cAlias
  858.       select (cAlias)
  859.    endif
  860.     
  861. RETURN cStruname
  862. *-- Eof: Makestru()
  863.  
  864. FUNCTION MakeStru2
  865. *-------------------------------------------------------------------------------
  866. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  867. *-- Date........: 05-27-1992
  868. *-- Notes.......: Create an empty STRUCTURE EXTENDED file, using DBASE print
  869. *--               redirection. If specified, the file will be created in the
  870. *--               subdirectory pointed to by the DOS environment variable
  871. *--               DBTMP, if it is set, otherwise in the current subdirectory.
  872. *--
  873. *--               Structure of a STRUCTURE EXTENDED file:
  874. *--               Field    Type  Len  Dec
  875. *--               -----------------------
  876. *--               FIELD_NAME  C   10    0
  877. *--               FIELD_TYPE  C    1    0
  878. *--               FIELD_LEN   N    3    0
  879. *--               FIELD_DEC   N    3    0
  880. *--               FIELD_IDX   C    1    0
  881. *--
  882. *-- Written for.: dBASE IV v1.1
  883. *-- Rev. History: None
  884. *-- Calls.......: TEMPNAME
  885. *-- Called by...: Any, except when printing
  886. *-- Usage.......: MakeStru(<lDBTMP>)
  887. *-- Example.....: cStruPath = MakeStru2(.T.)
  888. *-- Returns.....: The name, no extension, of the file created.
  889. *-- Parameters..: lDBTMP = create the file in the DBTMP subdirectory, or not.
  890. *-- Side Effects: WARNING: Do not call when printing.
  891. *-------------------------------------------------------------------------------
  892.  
  893.    parameter lDBTMP
  894.    private all
  895.    cDBTMP = ""  && TempName() will assign this, if lDBTMP
  896.    if lDBTMP
  897.       cFname = TempName( "dbf", .t. )
  898.    else
  899.       cFname = TempName( "dbf", .f. )
  900.    endif
  901.    cPath = iif( "" # cDBTMP, cDBTMP, set("DIRECTORY") ) + "\" + cFname + ".DBF"
  902.    dDate = date()
  903.    set printer to file (cPath)
  904.    set printer on
  905.    * Thanks to JPARSONS for the suggestion to document the header structure
  906.    ??? "{3}"           && various bit flags
  907.    ??? chr(year(dDate)-1900) + chr(month(dDate)) + ;
  908.        chr(day(dDate)) && date bytes in YYMMDD format
  909.    ??? "{0}{0}{0}{0}"  && no. of records
  910.    ??? "{193}{0}"      && no. of bytes in header
  911.    ??? "{19}{0}"       && no. of bytes per record
  912.    ??? "{0}{0}"        && reserved
  913.    ??? "{0}"           && incomplete transaction flag
  914.    ??? "{0}"           && encryption flag
  915.    ??? "{0}{0}{0}{0}{0}{0}{0}{0}{0}" + ;
  916.        "{0}{0}{0}"     && multi-user reserved
  917.    ??? "{0}"           && MDX flag
  918.    ??? "{0}{0}{0}"     && reserved
  919.    * field descriptors
  920.    ??? "{70}{73}{69}{76}{68}{95}{78}{65}{77}{69}{0}{67}{3}{0}{208}" + ;
  921.        "{72}{10}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"  && Field_Name
  922.    ??? "{70}{73}{69}{76}{68}{95}{84}{89}{80}{69}{0}{67}{13}{0}{208}" + ;
  923.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Type
  924.    ??? "{70}{73}{69}{76}{68}{95}{76}{69}{78}{0}{0}{78}{14}{0}{208}" + ;
  925.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Len
  926.    ??? "{70}{73}{69}{76}{68}{95}{68}{69}{67}{0}{0}{78}{17}{0}{208}" + ;
  927.        "{72}{3}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Dec
  928.    ??? "{70}{73}{69}{76}{68}{95}{73}{68}{88}{0}{0}{67}{20}{0}{208}" + ;
  929.        "{72}{1}{0}{0}{0}{1}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"   && Field_Idx
  930.    ??? "{13}{26}"
  931.    set printer to
  932.    set printer off
  933.  
  934. RETURN cFname
  935. *-- Eof() MakeStru2
  936.  
  937. FUNCTION TempName
  938. *-------------------------------------------------------------------------------
  939. *-- Programmer..: Martin Leon (HMAN)  Former Sysop, ATBBS
  940. *-- Date........: 05-27-1992
  941. *-- Notes.......: Obtain a name for a temporary file of a given extension
  942. *--               that does not conflict with existing files.
  943. *-- Written for.: dBASE IV, v1.5
  944. *-- Rev. History: Originally part of Makestru(), 6-12-1991
  945. *--               04/26/92, made a separate function - Jay Parsons
  946. *--               05/27/92, added lDBTMP option - Bowen Moursund
  947. *-- Calls.......: None
  948. *-- Called by...: Any
  949. *-- Usage.......: TempName( cExt , lDBTMP )
  950. *-- Example.....: Sortfile = TempName( "DBF" , .t. )
  951. *-- Returns.....: Name not already in use. Additionally, if the memvar
  952. *--               cDBTMP is declared before calling the function with
  953. *--               the lDBTMP option, it will be assigned the result
  954. *--               of getenv("DBTMP").
  955. *-- Parameters..: cExt   = Extension to be given file ( without the "." )
  956. *--               lDBTMP = Optional. If .t., function returns unique file
  957. *--                        name in the DBTMP subdirectory.
  958. *-- Side Effects: The function will return a unique filename for the DEFAULT
  959. *--               subdirectory if the lDBTMP option is used and the DOS
  960. *--               environment variable DBTMP does not point to a valid
  961. *--               subdirectory.
  962. *-------------------------------------------------------------------------------
  963.  
  964.    parameters cExt, lDBTMP
  965.    private all except cDBTMP
  966.    cDefDir = set("DIRECTORY")
  967.    if lDBTMP
  968.       cDBTMP = getenv("DBTMP")
  969.       if "" # cDBTMP
  970.      set directory to &cDBTMP.
  971.       endif
  972.    endif
  973.    do while .t.
  974.       Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
  975.       if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.;
  976.      .not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) )
  977.         exit
  978.       endif
  979.    enddo
  980.    set directory to &cDefDir.
  981.  
  982. RETURN Fname
  983. *-- Eof() TempName
  984.  
  985. PROCEDURE FileMove
  986. *-------------------------------------------------------------------------------
  987. *-- Programmer..: David Frankenbach (FRNKNBCH)
  988. *--               DF Software Development, Inc.
  989. *--               PO Box 87
  990. *--               Forest, VA, 24551
  991. *--               (804) 237-2342
  992. *-- Date........: 02/11/1992
  993. *-- Notes.......: This procedure gives the record movement allowed with EDIT
  994. *--               when you use a simple @SAY/GET..READ. It allows you to
  995. *--               pre/post process each record during editing, something you
  996. *--               can't do with EDIT. This works best with a single file,
  997. *--               although it would work with a parent->child relation. You
  998. *--               should:  SELECT child and SET SKIP to child. This will
  999. *--               allow the user to change the parent record pointer though!
  1000. *--               If you want to limit the child record movement to a single
  1001. *--               parent record, you can use a conditional index, or add logic
  1002. *--               to the routine to limit the record pointer movement. For these
  1003. *--               cases I have a seperate FileMove procedure, but they are not
  1004. *--               generic enough for public consumption.
  1005. *--
  1006. *--               These keys are trapped:
  1007. *--               UpArw, Shift-Tab, LeftArw, Ctrl-LeftArw, PgUp = 
  1008. *--                                                         backward one record
  1009. *--               DnArw, Tab, RightArw, Ctrl-RightArw, PgDn, Enter, Ctrl-End = 
  1010. *--                                                         forward one record
  1011. *--               Ctrl-PgUp = top of database or active index
  1012. *--               Ctrl-PgDn = bottom of database or active index
  1013. *-- Written for.: dBASE IV, 1.1
  1014. *-- Rev. History: 06/17/1991 - original routine.
  1015. *--               02/07/1992 -- Ken Mayer, brought into one PROCEDURE,
  1016. *--               rather than a function and a procedure ...
  1017. *--               02/11/1992 -- Author, additional documentation
  1018. *--                             Released into Public Domain
  1019. *-- Calls.......: None
  1020. *-- Called by...: None
  1021. *-- Usage.......: do FileMove with <nKey>
  1022. *--               where: <nKey> is the return value of readkey()
  1023. *-- Example.....: lMove = .t.  && if you want the user to be able to move the 
  1024. *--                            && record pointer in my applications if the user
  1025. *--                            && is adding a new record I usually lMove = .f.,
  1026. *--                            && for editing I allow them to move through the
  1027. *--                            && records.
  1028. *--               lOk = .t.
  1029. *--               do while ( lOk )
  1030. *--                  do Mem_Load               && load memvars from record
  1031. *--                  @say/gets                 && display/get the memvars
  1032. *--                  read
  1033. *--                  i = readkey()             && grab last key ...
  1034. *--                  lOk = ( i <> 27 )         && if Esc was pressed lOK is false
  1035. *--                  if ( lOk )
  1036. *--                     if ( i > 256 )         && if record is changed
  1037. *--                        do Mem_Unload       && replace dbf fields from memvars
  1038. *--                     endif  && ( i > 256 )
  1039. *--                     if ( lMove )           && if ok to move record pointer
  1040. *--                        do FileMove with i  && <----- Move it
  1041. *--                     else
  1042. *--                        lOk = .f.            && terminate loop if .not. lMove
  1043. *--                     endif  && ( lMove )
  1044. *--                  endif && (lOK)
  1045. *--               enddo && while (lOK)
  1046. *-- Parameters..: nKey = last keystroke from a READKEY() call ...
  1047. *-- Returns.....: None
  1048. *-- Side Effects: Moves record pointer in current file if lMove = .t.
  1049. *-------------------------------------------------------------------------------
  1050.     parameter nKey
  1051.     private n
  1052.     
  1053.     m->n = m->nKey
  1054.     if ( m->n > 255 )     && if value is > 256, record has changed, but we want
  1055.        m->n = m->n - 256  && values < 256 to figure out which direction to move
  1056.     endif                 && from the readkey() table
  1057.     
  1058.     do case
  1059.     
  1060.        *-- keys to move backward through database 1 record at a time ...
  1061.        *--  LeftArw, Ctrl-LeftArw, UpArw, Shift-Tab, PgUp
  1062.        case ( m->n = 0 ) .or. ( m->n = 2 ) .or. ( m->n = 4 ) .or. ( m->n = 6 )
  1063.           if ( .not. bof() )                && if not at beginning of file
  1064.          skip -1                        && move backward one record
  1065.           endif
  1066.     
  1067.        *-- keys to move forward through database 1 record at a time ...
  1068.        *--  RightArw, Ctrl-RightArw, DownArw, Tab, PgDn, Ctrl-End, Enter
  1069.        case ( m->n = 1 ) .or. ( m->n = 3 ) .or. ( m->n = 5 ) .or. ( m->n = 7 );
  1070.              .or. ( m->n = 14) .or. ( m->n = 15)
  1071.           if ( .not. eof() )                && if not end of file
  1072.          skip 1                         && move forward one record
  1073.           endif
  1074.           if ( eof() )                      && if we're now at the EOF,
  1075.          goto bottom                    && go back to last record ...
  1076.           endif
  1077.     
  1078.        *-- go to toP of database, Ctrl-PgUp
  1079.        case ( m->n = 34 )
  1080.           goto top
  1081.     
  1082.        *-- go to BOTtoM of database, Ctrl-PgDn
  1083.        case ( m->n = 35 )
  1084.           goto bottom
  1085.     
  1086.     endcase
  1087.  
  1088. RETURN
  1089. *-- EoP: FileMove
  1090.  
  1091. FUNCTION Used
  1092. *-------------------------------------------------------------------------------
  1093. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1094. *-- Date........: 02/28/1992
  1095. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1096. *--               from DBA Magazine (11/91) calls a function that checks
  1097. *--               to see if a DBF file is open ... 
  1098. *-- Written for.: dBASE IV, 1.5
  1099. *-- Rev. History: 05/15/1992 -- Original
  1100. *--               02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
  1101. *--               a much simpler way to do this ...
  1102. *-- Called by...: Any
  1103. *-- Calls.......: None
  1104. *-- Usage.......: Used("<cFile>")
  1105. *-- Example.....: if used("Library")
  1106. *--                  select library
  1107. *--               else
  1108. *--                  select select()
  1109. *--                  use library
  1110. *--               endif
  1111. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1112. *-- Parameters..: cFile = file to check for
  1113. *-------------------------------------------------------------------------------
  1114.     
  1115.     parameters cFile
  1116.     
  1117. RETURN (select(cFile) # 0)
  1118. *-- EoF: Used()
  1119.  
  1120. FUNCTION MDXbyte
  1121. *-------------------------------------------------------------------------------
  1122. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1123. *-- Date........: 05-21-1992
  1124. *-- Notes.......: Sets the MDX byte in a DBF header ON or OFF.
  1125. *--               The DBF must not be open when the function is called.
  1126. *-- Written for.: dBASE IV v1.5
  1127. *-- Rev. History: None
  1128. *-- Calls.......: dBASE low level file functions
  1129. *-- Called by...: Any
  1130. *-- Usage.......: MDXbyte(<cDBFpath>,<cOnOff>)
  1131. *-- Example.....: lByteSet = MDXbyte("mydbf.dbf","OFF")
  1132. *-- Returns.....: .T. if successful
  1133. *-- Parameters..: cDBFpath = the [path]filename.ext of the DBF
  1134. *--               cOnOff   = "ON" or "OFF"
  1135. *-------------------------------------------------------------------------------
  1136.  
  1137.    parameters cDBFpath,cOnOff
  1138.    private all
  1139.    cOnOff = upper(cOnOff)
  1140.    * check the validity of the parameters
  1141.    lSuccess = ( pcount() = 2 .AND. cOnOff $ "ON|OFF" .AND. file(cDBFpath) )
  1142.    if lSuccess
  1143.       nHandle = fopen(cDBFpath,"RW")
  1144.       if nHandle > 0
  1145.      if fseek(nHandle, 28) = 28
  1146.         lSuccess = ( fwrite(nHandle, iif(cOnOff="OFF",chr(0),chr(1))) = 1 )
  1147.      else
  1148.         lSuccess = .F.
  1149.      endif
  1150.      lClosed = fclose(nHandle)
  1151.       else
  1152.      lSuccess = .F.
  1153.       endif
  1154.    endif
  1155.  
  1156. RETURN lSuccess
  1157. *-- Eof() MDXbyte
  1158.  
  1159. FUNCTION aDir
  1160. *-------------------------------------------------------------------------------
  1161. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1162. *-- Date........: 07-24-1992
  1163. *-- Notes.......: aDir() creates a public array gaDir[ n, 5 ] containing
  1164. *--               directory information. gaDir[ n, 5 ] is limited to 234
  1165. *--               rows (files) or less, depending on the memory available.
  1166. *--
  1167. *--                     Structure of 2D array gaDir[ n, 5 ]:
  1168. *--
  1169. *--                     Col  Contents             Type       Width
  1170. *--                     ------------------------------------------
  1171. *--                       1  File Name            Character     12
  1172. *--                       2  Date (mm/dd/yy)      Date           8
  1173. *--                       3  Time (hh:mm:ss)      Character      8
  1174. *--                       4  Size (bytes)         Numeric       10
  1175. *--                       5  Attributes           Character      6
  1176. *--
  1177. *--               aDir() makes use of SEARCH.BIN, and credit is due its
  1178. *--               author (Roland Boucherau, Borland Technical Support). 
  1179. *--               See SEARCH.ASM or SEARCH.TXT source for details.
  1180. *--               *****************************
  1181. *--               **** REQUIRES SEARCH.BIN ****
  1182. *--               *****************************
  1183. *-- Written for.: dBASE IV, v1.5
  1184. *-- Rev. History: None
  1185. *-- Calls.......: None
  1186. *-- Called by...: Any
  1187. *-- Usage.......: adir( <cFMask>, <cBINpath>, <cAttr> )
  1188. *-- Examples....: nFiles = adir( "d:\app\fu*.db?", "d:\dbase4\library\", "" )
  1189. *--               nFiles = adir( cPathSkel )
  1190. *--               nFiles = adir( "c:\*.*", "", "RHSD" )
  1191. *-- Returns.....: Number of matching files found: rows in gaDir[]
  1192. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1193. *--                           want, like the DOS DIR command. Wildcards OK.
  1194. *--               cBINpath = Optional path to Search.Bin. If omitted,
  1195. *--                          Search.Bin must be in current subdirectory.
  1196. *--                          Include the trailing backslash.
  1197. *--               cAttr = Optional file attribute mask string.
  1198. *--
  1199. *--                             Mask Codes
  1200. *--                            ------------
  1201. *--                            R - Read Only
  1202. *--                            H - Hidden
  1203. *--                            S - System
  1204. *--                            D - Directory
  1205. *--                            V - Volume
  1206. *--                            A - Archive
  1207. *--
  1208. *--                       If cAttr is omitted, null, or blank, gaDir[] will
  1209. *--                       contain only 'ordinary' files, i.e. files without
  1210. *--                       HSDV attributes. If V is specified in the mask,
  1211. *--                       ONLY volume labels are matched. Any other attribute
  1212. *--                       or combination of attributes results in those files
  1213. *--                       AND ordinary files being matched.
  1214. *-------------------------------------------------------------------------------
  1215.  
  1216.     parameters cPathSkel, cBINpath, cAttr
  1217.     private all except gaDir
  1218.     cModule = iif( pcount() >= 2, cBINpath + "search.bin", "search.bin" )
  1219.     store upper( iif( pcount() >= 3, left( cAttr + "      ", 6 ), "      " ) ) ;
  1220.          to cAttr, cFAttr
  1221.     cFSkel = left( cPathSkel + space(12), max( len( cPathSkel ), 12 ) )
  1222.     cFName = cFSkel
  1223.     * ( memory() * 3.4 ) is a guess on max rows before 'Insufficient Memory'
  1224.     nMaxRows = min( memory() * 3.4, 234 )  && 234 is the absolute maximum
  1225.     nFCount = 0
  1226.     load ( cModule )
  1227.     nResult = call( "Search", 1, cFName, cAttr )
  1228.     if nResult = 0
  1229.     do while nResult = 0 .and. nFCount <= nMaxRows
  1230.         nFCount = nFCount + 1
  1231.         nResult = call( "Search" , 2, cFName )
  1232.     enddo
  1233.     nFCount = min( nMaxRows, nFCount )
  1234.     release gaDir
  1235.     public array gaDir[ nFCount, 5 ]
  1236.     cFName = cFSkel
  1237.     cFDate = "  /  /  "
  1238.     cFTime = "  :  :  "
  1239.     nFSize = 0
  1240.     n = 1
  1241.     nResult = ;
  1242.     call( "Search", 1, cFName, cFAttr, cFDate, cFTime, nFSize )
  1243.     do while nResult = 0 .AND. n <= nFCount
  1244.         store cFName to         gaDir[ n, 1 ]
  1245.         store ctod( cFDate ) to gaDir[ n, 2 ]
  1246.         store cFTime to         gaDir[ n, 3 ]
  1247.         store nFSize to         gaDir[ n, 4 ]
  1248.         store cFAttr to         gaDir[ n, 5 ]
  1249.         nResult = ;
  1250.          call( "Search", 2, cFName, cFAttr, cFDate, cFTime, nFSize )
  1251.         n = n + 1
  1252.     enddo
  1253.     else
  1254.     release gaDir
  1255.     endif
  1256.     release module Search
  1257.  
  1258. RETURN nFCount
  1259. *-- EoF: aDir()
  1260.  
  1261. FUNCTION DbfDir
  1262. *-------------------------------------------------------------------------------
  1263. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1264. *-- Date........: 07-03-1992
  1265. *-- Notes.......: DbfDir() creates or OVERWRITES DdbDir.Dbf, and populates
  1266. *--               it with directory information. The function uses the DOS
  1267. *--               5.0 DIR command and requires DOS 5.0.
  1268. *--
  1269. *--                          Structure of DBFDIR.DBF
  1270. *--                          -----------------------
  1271. *--                          Field    Type  Len  Dec
  1272. *--                          F_NAME      C   12    0
  1273. *--                          F_DATE      D    8    0
  1274. *--                          F_TIME      C    8    0
  1275. *--                          F_SIZE      N   10    0
  1276. *--               *********************************************************
  1277. *--               * DO NOT CALL THIS ROUTINE WHILE PRINTING (the function *
  1278. *--               * uses Print Redirection ...)                           *
  1279. *--               *********************************************************
  1280. *-- Written for.: dBASE IV v1.5, DOS 5.0
  1281. *-- Rev. History: None
  1282. *-- Calls.......: TempName()           Function in FILES.PRG
  1283. *-- Called by...: None
  1284. *-- Usage.......: DbfDir( "<cPathSkel>", <lHidSys> )
  1285. *-- Examples....: nFiles = DbfDir( "*.dbf" )
  1286. *--               nFiles = DbfDir( "*.dbf", .t. )
  1287. *-- Returns.....: Number of matching files found: reccount() of DbfDir.dbf
  1288. *-- Parameters..: cPathSkel = the directory path and file skeleton that you
  1289. *--                           want, like the DOS DIR command. Wildcards OK.
  1290. *--               lHidSys   = Optional. If .t., hidden & system files
  1291. *--                           are included.
  1292. *-------------------------------------------------------------------------------
  1293.  
  1294.     parameters cPathSkel, lHidSys
  1295.     private all
  1296.     cDBTMP = ""
  1297.     cTmpFile = tempname( "txt", .t. ) + ".txt"
  1298.     cTmpFile = iif( "" = cDBTMP, cTmpFile, cDBTMP + "\" + cTmpFile )
  1299.     cDirParms = iif( lHidSys, "/B/A-D/ON", "/B/A-D-H-S/ON" )
  1300.     run dir &cPathSkel. &cDirParms. > &cTmpFile.
  1301.     nFiles = 0
  1302.     if fsize( cTmpFile ) > 0
  1303.     lSafeOn = ( set( "safety" ) = "ON" )
  1304.     set safety off
  1305.     set printer to file DbfDir.dbf  && create DbfDir.dbf
  1306.     set printer on
  1307.     * first byte of header - various bit flags
  1308.     ??? "{3}"
  1309.     * next 3 bytes - file date in binary YYMMDD
  1310.     ??? chr(year(date())-1900) + chr(month(date())) + chr(day(date()))
  1311.     * the rest of the header, field descriptors, and records if any
  1312.     ??? "{0}{0}{0}{0}{161}{0}{39}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1313.     "{0}{0}{0}{0}{0}{0}{0}{1}{1}{70}{95}{78}{65}{77}{69}{0}{0}{0}{0}{0}"+;
  1314.     "{67}{0}{0}{0}{0}{12}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"+;
  1315.     "{70}{95}{68}{65}{84}{69}{0}{0}{0}{0}{0}{68}{0}{0}{0}{0}"
  1316.     ??? "{8}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{84}"+;
  1317.     "{73}{77}{69}{0}{0}{0}{0}{0}{67}{0}{0}{0}{0}{8}{0}{0}{0}{0}{0}{0}"+;
  1318.     "{0}{0}{0}{0}{0}{0}{0}{0}{0}{70}{95}{83}{73}{90}{69}{0}{0}{0}{0}{0}"+;
  1319.     "{78}{0}{0}{0}{0}{10}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}{0}"
  1320.     ??? "{0}{0}{0}{13}{26}"
  1321.     set printer to
  1322.     set printer off
  1323.     cAlias = alias()
  1324.     select select()
  1325.     use DbfDir
  1326.     append from ( cTmpFile ) sdf
  1327.     goto top
  1328.     cPath = parspath( cPathSkel )
  1329.     scan
  1330.         replace f_size with fsize( cPath + f_name ),;
  1331.             f_date with fdate( cPath + f_name ),;
  1332.             f_time with ftime( cPath + f_name )
  1333.     endscan
  1334.     nFiles = reccount()
  1335.     use
  1336.     if lSafeOn
  1337.         set safety on
  1338.     endif
  1339.     if "" # cAlias
  1340.         select ( cAlias )
  1341.     endif
  1342.     endif
  1343.     erase ( cTmpFile )
  1344.  
  1345. RETURN nFiles
  1346. *-- EoF: DBFDir()
  1347.  
  1348. FUNCTION ParsPath
  1349. *-------------------------------------------------------------------------------
  1350. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  1351. *-- Date........: 07-16-1992
  1352. *-- Notes.......: ParsPath() extracts and returns the path from a
  1353. *--               full path file specification.
  1354. *-- Written for.: dBASE IV v1.1
  1355. *-- Rev. History: None
  1356. *-- Calls.......: None
  1357. *-- Called by...: Any
  1358. *-- Usage.......: ParsePath( "<cFullPath>" )
  1359. *-- Example.....: set fullpath on
  1360. *--               cDBF = dbf()
  1361. *--               cPath = ParsPath( cDBF )
  1362. *-- Returns.....: The path only, including the trailing backslash,
  1363. *--               of the full path file specification
  1364. *-- Parameters..: cFullPath = a full path file spec, e.g. "c:\dbase\dbase.exe"
  1365. *-------------------------------------------------------------------------------
  1366.  
  1367.     parameter cFullPath
  1368.     private all
  1369.     cPath = ""
  1370.     if "\" $ cFullPath
  1371.     nPos = 1
  1372.     do while left( right ( cFullPath, nPos ), 1 ) # "\"
  1373.         nPos = nPos + 1
  1374.     enddo
  1375.     cPath = substr( cFullPath, 1, len( cFullPath ) - nPos + 1)
  1376.     endif
  1377.  
  1378. RETURN cPath
  1379. *-- EoF: ParsPath()
  1380.  
  1381. PROCEDURE TagPop
  1382. *-------------------------------------------------------------------------------
  1383. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1384. *-- Date........: 09/08/1992
  1385. *-- Notes.......: Used to bring up a list of MDX tags on screen for the user,
  1386. *--               so they can change the current tag ... This is based on an
  1387. *--               article by Susan Perschke and Mike Liczbanski in "Data Based 
  1388. *--               Advisor", December, 1991, and another by Malcom C. Rubel,
  1389. *--               Data Based Advisor, September, 1992.
  1390. *--                 The idea is to bring up a picklist of all MDX tags for
  1391. *--               the current database file, showing the tag name, and 
  1392. *--               expression, as well as whether or not it's unique, has a
  1393. *--               FOR clause, and whether it's ascending or descending ...
  1394. *--                 However, as an additional bonus, if the user selects one
  1395. *--               of the MDX tags, the current tag is changed to the one the
  1396. *--               user selects. The tag with a "*" by it is the current tag.
  1397. *-- Written for.: dBASE IV, 1.5
  1398. *-- Rev. History: 09/08/1992 -- Version 1
  1399. *--               09/21/1992 -- Version 1.1 -- added more docs and removed
  1400. *--                               reference to parameters of which there are
  1401. *--                               none ... (changed my mind)
  1402. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1403. *--               CENTER               Procedure in PROC.PRG
  1404. *-- Called by...: Any
  1405. *-- Usage.......: DO TagPop
  1406. *-- Example.....: ON KEY LABEL F8 DO TagPop
  1407. *-- Returns.....: None (well, ok -- it resets the MDX tag if you select one)
  1408. *-- Parameters..: None
  1409. *-------------------------------------------------------------------------------
  1410.  
  1411.     private nBar, cPrompt, cBorder, cTag, nTag, nTagTotal, cFor, cUnique,;
  1412.              cDir, cKey
  1413.     
  1414.     *-- Disable left/right arrow keys to prevent an accidental exit
  1415.     on key label leftarrow  ?? chr(7)
  1416.     on key label rightarrow ?? chr(7)
  1417.     
  1418.     *-- Save current screen
  1419.     save screen to sTag
  1420.     cBorder = set("BORDER")
  1421.     activate screen
  1422.     
  1423.     *-- define the screen/window
  1424.     define window wTagPop from 5,2 to 20,77 double
  1425.     activate screen
  1426.     do shadow with 5,2,20,77
  1427.     activate window wTagPop
  1428.     
  1429.     *-- check to see if there are any tags ... or an active database ...
  1430.     if isblank(alias()) .or. isblank(tag(1))
  1431.     
  1432.         *-- if not, display appropriate error message
  1433.         if isblank(alias())
  1434.             do center with 1,75,"","** No active Database ... **"
  1435.         else
  1436.             do center with 1,75,"","** No active .MDX file for this .DBF **"
  1437.         endif
  1438.         x=inkey(0)  && wait for user to press a key ...
  1439.         
  1440.     else   && we DO have an active database AND active MDX file
  1441.     
  1442.         *-- headings
  1443.         do center with 0,75,"","Select new MDX Tag"
  1444.         @2,1 say "Name"
  1445.         @2,10 say "For"
  1446.         @2,14 say "Unq"
  1447.         @2,18 say "Seq"
  1448.         @2,22 say "Expression"
  1449.         @3,1 say replicate(chr(196),72)  && ─
  1450.         
  1451.         *-- popup will display here
  1452.         
  1453.         *-- footings (as it were)
  1454.         @10,1 say replicate(chr(196),72)  && ─
  1455.         @11,3 say chr(251)+" in 'For' column means there is a 'For' clause"
  1456.         @12,3 say chr(251)+" in 'Unq' column means the tag is set to 'Unique'"
  1457.         @13,3 say chr(24)+" in 'Seq' means tag is 'Ascending', "+;
  1458.             chr(25)+" means tag is descending"
  1459.         
  1460.         *-- define the popup
  1461.         set border to none  && no border for popup
  1462.         define popup pTag from 3,0 to 10,73;
  1463.            message " Press ENTER to select new index order ... ESC to exit ..."
  1464.         nBar = 1                        && first bar
  1465.         *-- place a * if no tag is currently active
  1466.         cPrompt = iif(TagNo()=0,"*"," ")+" No Index"  && bar 1 will always be this
  1467.         cPrompt = cPrompt + space(11)+"(Natural Order)"
  1468.         nTag = 0
  1469.         
  1470.         *-- loop to get the rest of 'em ...
  1471.         nTagTotal = tagcount()           && get total number of tags
  1472.         do while nTag <= nTagTotal       && loop until no more tags
  1473.            define bar nBar of pTag prompt (cPrompt)
  1474.             nTag = nTag + 1
  1475.             cDefault = iif(TagNo() = nTag,"*"," ")  && if current tag ...
  1476.             *-- the fun part of all this is getting the spacing "just right"
  1477.             *-- that's what all the IIF( ....,space(...)) stuff is about
  1478.             cTag    = tag(nTag)+iif(len(tag(nTag))<9,space(9-len(tag(nTag))),"")
  1479.             cFor    = iif(isblank(for(nTag))," ",chr(251))
  1480.             cUnique = iif(unique(nTag),chr(251)," ")
  1481.             cDir    = iif(descending(nTag),chr(25),chr(24)) && up/down arrows ...
  1482.             cKey    = iif(len(key(nTag))>57,left(key(nTag),52)+" ...",key(nTag))
  1483.             cKey    = iif(len(cKey)<57,cKey+space(57-len(cKey)),cKey)
  1484.             *-- here's the actual definition of the bars ...
  1485.            cPrompt = cDefault+cTag+"  "+cFor+"  "+cUnique+"  "+cDir+"  "+cKey
  1486.            nBar = nBar + 1
  1487.         enddo
  1488.         
  1489.         *-- turn it off when an item's been selected (or <Esc> was pressed)
  1490.         on selection popup pTag deactivate popup
  1491.         
  1492.         *-- do it
  1493.         activate popup pTag
  1494.         
  1495.         *-- Don't change index order if ESC pressed
  1496.         if bar() <> 0
  1497.             *-- Assign a null string to cPrompt if "No Index" selected
  1498.             cPrompt = iif(bar() = 1, "",tag(bar()-1))
  1499.            set order to (cPrompt)
  1500.         endif
  1501.         
  1502.         *-- cleanup
  1503.         release popup pTag
  1504.         set border to &cBorder
  1505.         
  1506.     endif
  1507.     deactivate window wTagPop
  1508.     release window wTagPop
  1509.     restore screen from sTag
  1510.     release screen sTag
  1511.     
  1512.     *-- re-enable left/right arrow keys
  1513.     on key label leftarrow
  1514.     on key label rightarrow
  1515.  
  1516. RETURN
  1517. *-- EoP: TagPop
  1518.  
  1519. FUNCTION AAppend
  1520. *-------------------------------------------------------------------------------
  1521. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1522. *-- Date........: 04/xx/1992
  1523. *-- Notes.......: Appends a text file into an array. This routine is limited to
  1524. *--               text files of 1,170 lines, and 254 characters per line.
  1525. *--               The text file must be an ASCII Txt formatted file. Taken from
  1526. *--               Technotes, April, 1992.
  1527. *-- Written for.: dBASE IV, 1.5
  1528. *-- Rev. History: None
  1529. *-- Calls.......: TextLine()           Function in FILES.PRG
  1530. *-- Called by...: Any
  1531. *-- Usage.......: AAppend(<cFileName>,<aArrayName>)
  1532. *-- Example.....: ?AAppend("CONFIG.DB","aConfig")
  1533. *-- Returns.....: .T.
  1534. *-- Parameters..: cFileName  = Name of DOS Text file to read into array
  1535. *--               aArrayName = Name of array to create. If it already exists,
  1536. *--                            this array will be destroyed and overwritten.
  1537. *-------------------------------------------------------------------------------
  1538.  
  1539.    parameters cFileName, aArrayName
  1540.    private aTArray, nLines, nX, nHandle
  1541.  
  1542.    *-- assign array name to a temp variable name ...
  1543.    aTArray = aArrayName
  1544.    *-- if it exists, get rid of it, and then re-define it
  1545.    release &aTArray
  1546.    public  &aTArray
  1547.    nLines = TextLine(cFileName)  && get number of lines
  1548.    declare &aTArray[min(nLines,1170)]
  1549.  
  1550.    *-- get file handle
  1551.    nHandle = fopen(cFileName)
  1552.  
  1553.    *-- store the file into the array
  1554.    nX = 1
  1555.    do while nX <= nLines
  1556.       store fgets(nHandle,254) to &aTArray[nX]
  1557.       nX = nX + 1
  1558.    enddo
  1559.  
  1560.    *-- close the file
  1561.    nHandle = fClose(nHandle)
  1562.  
  1563. RETURN .T.
  1564. *-- EoF: AAppend()
  1565.  
  1566. FUNCTION FDel
  1567. *-------------------------------------------------------------------------------
  1568. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1569. *-- Date........: 04/xx/1992
  1570. *-- Notes.......: Deletes a given portion of a file. Taken from TechNotes,
  1571. *--               April, 1992
  1572. *--                 Used to delete a portion of a file (text or binary) from
  1573. *--               the beginning of the file, the end of file or current pointer
  1574. *--               position. This routine accomplishes it's task by writing the
  1575. *--               data you want to keep to a temp file, then overwriting
  1576. *--               the data you no longer want with the temp file. If you are on
  1577. *--               a network, make sure that you set TMP (or DBTMP) to either
  1578. *--               a local drive, or one where you have full rights.
  1579. *-- Written for.: dBASE IV, 1.5
  1580. *-- Rev. History: None
  1581. *-- Calls.......: TempFile()           Function in FILES.PRG
  1582. *-- Called by...: Any
  1583. *-- Usage.......: FDel(<nHandle>,<nBytes>,<nStart>)
  1584. *-- Example.....: nOpen = fopen("TEXT.TXT","RW")
  1585. *--               ?FDel(nOpen,1000,1)
  1586. *-- Returns.....: Logical
  1587. *-- Parameters..: nHandle = file handle number, as returned by FOPEN
  1588. *--               nBytes  = number of characters (bytes) to delete in file
  1589. *--               nStart  = starting position, where:
  1590. *--                          0 is the beginning of the file
  1591. *--                          1 is the current file pointer position
  1592. *--                          2 is the end of the file
  1593. *-------------------------------------------------------------------------------
  1594.  
  1595.    parameters nHandle, nBytes, nStart
  1596.    private nTemp,cTemp,nSave,nSeek,nRead,nWrite,lFlush,nClose
  1597.  
  1598.    *-- create a temporary file
  1599.    cTemp = tempfile("ADM")
  1600.    *-- save current position in file
  1601.    nSave = fseek(nHandle,0,1)
  1602.  
  1603.    do case
  1604.       case nStart = 0                  && beginning of file
  1605.        nSeek = fseek(nHandle,nBytes,0)
  1606.        nTemp = fcreate(cTemp)
  1607.        do while .not. feof(nHandle)
  1608.           nRead = fread(nHandle,254)
  1609.           nWrite = fwrite(nTemp,nRead)
  1610.           lFlush = fflush(nTemp)
  1611.        enddo
  1612.        nSeek = fseek(nTemp,0,0)
  1613.        nSeek = fseek(nHandle,0,0)
  1614.        do while .not. feof(nTemp)
  1615.           nRead = fread(nTemp,254)
  1616.           nWrite = fwrite(nHandle,nRead)
  1617.           lFlush = fflush(nHandle)
  1618.        enddo
  1619.        nWrite = fwrite(nHandle,chr(0),0)
  1620.        nClose = fclose(nTemp)
  1621.        nSeek = fseek(nHandle,nSave,0)
  1622.  
  1623.       case nStart = 1                  && Current Location
  1624.        *-- skip these bytes
  1625.        nSeek = fseek(nHandle,nDelete,1)
  1626.        *-- write the rest to a temp file
  1627.        nTemp=fCreate(cTemp)
  1628.        do while .not. feof(nHandle)
  1629.           nRead = fread(nHandle,254)
  1630.           nWrite = fwrite(nTemp,nRead)
  1631.           lFlush = fflush(nTemp)
  1632.        enddo
  1633.  
  1634.        nSeek = fseek(nTemp,0,0)
  1635.        nSeek = fseek(nHandle,nSave,0)
  1636.        nWrite = fwrite(nHandle,chr(0),0)
  1637.  
  1638.        do while .not. feof(nTemp)
  1639.           nRead = fread(nTemp,254)
  1640.           nWrite = fwrite(nHandle,nRead)
  1641.           lFlush = fflush(nHandle)
  1642.        enddo
  1643.        nSeek = fseek(nHandle,nSave,0)
  1644.        nClose = fclose(nTemp)
  1645.  
  1646.       case nStart = 2                  && End of File
  1647.        nSeek = fseek(nHandle,-1*abs(nDelete),2)
  1648.        nWrite = fwrite(nHandle,chr(0),0)
  1649.    endcase
  1650.    erase (cTemp)
  1651.  
  1652. RETURN (ferror() = 0)
  1653. *-- EoF: FDel()
  1654.  
  1655. FUNCTION FGetLine
  1656. *-------------------------------------------------------------------------------
  1657. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1658. *-- Date........: 04/xx/1992
  1659. *-- Notes.......: Used to extract a line of text from a text file. 
  1660. *-- Written for.: dBASE IV, 1.5
  1661. *-- Rev. History: None
  1662. *-- Calls.......: TLine()              Function in FILES.PRG
  1663. *--               TLineNo()            Function in FILES.PRG
  1664. *-- Called by...: Any
  1665. *-- Usage.......: FGetLine(<cFileName>,<cLookup>,[<lCase>],[<lEntire>])
  1666. *-- Example.....: ?FGetLine("config.db","command",.f.,.f.)
  1667. *-- Returns.....: A character expression
  1668. *-- Parameters..: cFileName = Name of file to extract text from
  1669. *--               cLookup   = Text to look for
  1670. *--               lCase     = Case sensitive? (Logical = .t. or .f.)
  1671. *--                           If empty, default is .F.
  1672. *--               lEntire   = Return entire line, or the rest of the line
  1673. *--                           .t. = return the entire line
  1674. *--                           .f. = return everything following cLookup
  1675. *--                           If empty, default is .t.
  1676. *-------------------------------------------------------------------------------
  1677.  
  1678.    parameters cFileName, cLookup, lCase, lEntire
  1679.    private nLine, cText
  1680.  
  1681.    *-- defaults
  1682.    lCase   = iif(pcount() <= 2,.f.,lCase)
  1683.    lEntire = iif(pcount() <=3,.t.,lEntire)
  1684.    *-- get the line ...
  1685.    nLine = TLineNo(cFile,cLookup,lCase)
  1686.    cText = iif(nLine<=0,"",TLine(cFile,nLine,lCase))
  1687.    cResult = upper(cText)
  1688.  
  1689. RETURN iif(lEntire,cText,substr(cText,at(upper(cLookup),cResult)+len(cLookup)))
  1690. *-- EoF: FGetLine()
  1691.  
  1692. FUNCTION FIns
  1693. *-------------------------------------------------------------------------------
  1694. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1695. *-- Date........: 04/xx/1992
  1696. *-- Notes.......: Inserts specified number of NULLS into a low-level file.
  1697. *--               Taken from Technotes, April, 1992. FIns() works the way
  1698. *--               FDel() works, but in reverse.  See comments in FDel about
  1699. *--               temp directory ...
  1700. *-- Written for.: dBASE IV, 1.5
  1701. *-- Rev. History: None
  1702. *-- Calls.......: TempFile()           Function in FILES.PRG
  1703. *-- Called by...: Any
  1704. *-- Usage.......: FIns(<nHandle>,<nBytes>,<nStart>)
  1705. *-- Example.....: nOpen = fopen("TEST.TXT","RW")
  1706. *--               ?FIns(nOpen,10,1)
  1707. *-- Returns.....: Logical
  1708. *-- Parameters..: nHandle = File Handle from FOPEN() function
  1709. *--               nBytes  = Number of nulls to insert into file
  1710. *--               nStart  = Location in file to start at, where:
  1711. *--                         0 = Beginning of file
  1712. *--                         1 = Current file pointer
  1713. *--                         2 = End of file
  1714. *-------------------------------------------------------------------------------
  1715.  
  1716.    parameters nHandle, nBytes, nStart
  1717.    private nTemp, cTemp, nSave, nRead, nWrite, nSeek, lFlush, nX, nClose
  1718.  
  1719.    cTemp = TempFile("ADM")      && create temp file
  1720.    nSave = fseek(nHandle,0,1)   && save current position
  1721.  
  1722.    do case
  1723.       case nStart = 0           && beginning of file
  1724.        nTemp = fcreate(cTemp)
  1725.        nX = 1
  1726.        do while nX <= nBytes
  1727.           nWrite = fwrite(nTemp,chr(0),1)
  1728.           nX = nX + 1
  1729.        enddo
  1730.        nSeek = fseek(nHandle,0,0)
  1731.        do while .not. feof(nHandle)
  1732.           nRead = fread(nHandle,254)
  1733.           nWrite = fwrite(nTemp,nRead)
  1734.           lFlush = fflush(nTemp)
  1735.        enddo
  1736.        nSeek = fseek(nTemp,0,0)
  1737.        nSeek = fseek(nHandle,0,0)
  1738.        do while .not. feof(nTemp)
  1739.           nRead = fread(nTemp,254)
  1740.           nWrite = fwrite(nHandle,nRead)
  1741.           lFlush = fflush(nHandle)
  1742.        enddo
  1743.        nWrite = fwrite(nHandle,chr(0),0)
  1744.        nclose = fclose(ntemp)
  1745.        nSeek = fseek(nHandle,0,0)
  1746.  
  1747.       case nStart = 1                  && current location
  1748.        *-- write the rest to a temp file
  1749.        nTemp = fcreate(cTemp)
  1750.        do while .not. feof(nHandle)
  1751.           nRead = fread(nHandle,254)
  1752.           nWrite = fwrite(nTemp,nRead)
  1753.           lFlush = fflush(nTemp)
  1754.        enddo
  1755.        nSeek = fseek(nHandle,nSave,0)
  1756.        nX = 1
  1757.        do while nX <= nBytes
  1758.           nWrite = fWrite(nHandle,chr(0),1)
  1759.           nX = nX + 1
  1760.        enddo
  1761.        nSeek = fseek(nTemp,0,0)
  1762.        do while .not. feof(nTemp)
  1763.           nRead = fread(nTemp,254)
  1764.           nWrite = fwrite(nHandle,nRead)
  1765.           lFlush = fflush(nHandle)
  1766.        enddo
  1767.        nSeek = fseek(nHandle,nSave,0)
  1768.        nClose = fclose(nTemp)
  1769.  
  1770.       case nStart = 2                  && End of File
  1771.        nSeek = fseek(nHandle,0,2)
  1772.        nX = 1
  1773.        do while nX <= nBytes
  1774.           nWrite = fwrite(nHandle,chr(0),1)
  1775.           nX = nX + 1
  1776.        enddo
  1777.    endcase
  1778.    erase (cTemp)
  1779.  
  1780. RETURN (ferror() = 0)
  1781. *-- EoF: FIns()
  1782.  
  1783. FUNCTION GetInfo
  1784. *-------------------------------------------------------------------------------
  1785. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1786. *-- Date........: 04/xx/1992 
  1787. *-- Notes.......: This retrieves information from STATUS that you cannot get
  1788. *--               with the dBASE IV function SET(). See 'parameters' below for
  1789. *--               list of keywords.
  1790. *--               CAUTION: If you have ALTERNATE set, you need to reset it after
  1791. *--                 the function executes. SET ALTERNATE TO must be used instead
  1792. *--                 of LIST STATUS TO filename, since the print destination
  1793. *--                 would always show as a file. All results that are returned
  1794. *--                 are returned as character types, including ones that
  1795. *--                 return numbers (use VAL() to look at/use returned value as
  1796. *--                 a number).
  1797. *-- Written for.: dBASE IV, 1.5
  1798. *-- Rev. History: None
  1799. *-- Calls.......: TempFile()           Function in FILES.PRG
  1800. *--               TextLine()           Function in FILES.PRG
  1801. *--               AAppend()            Function in FILES.PRG
  1802. *-- Called by...: Any
  1803. *-- Usage.......: GetInfo(<cKeyWord>,[<cKeyWord2>])
  1804. *-- Example.....: ? GetInfo("F5")
  1805. *-- Returns.....: Character expression
  1806. *-- Parameters..: cKeyWord  = Item you are looking for status of, options 
  1807. *--                           listed return the following:
  1808. *--                           WORK    Number of work area you are currently
  1809. *--                                   in - whether or not a database is in use.
  1810. *--                           PRINT   Current printer destination where output
  1811. *--                                   is directed (PRN, NUL, LPT1, COM1) as 
  1812. *--                                   set by SET PRINTER TO.
  1813. *--                           ERROR   The error condition set by ON ERROR
  1814. *--                           ESCAPE  The escape condition set by ON ESCAPE
  1815. *--                           F2 to F10, Ctrl-F1 to Ctrl-F10, Shift-F1 to
  1816. *--                              Shift-F10 
  1817. *--                                   The current setting of each key as set
  1818. *--                                   by SET FUNCTION <label> TO
  1819. *--                           **** The following require a second paramter
  1820. *--                                (cKeyWord2 ...)
  1821. *--                           PAGE,LINE  Line number specified by 
  1822. *--                                                 ON PAGE AT LINE
  1823. *--                                      in the page handling routine
  1824. *--                           HANDLE,<filename>  The handle number of the low-
  1825. *--                                      level file specified by <filename>
  1826. *--                           NAME,<filehandle>  The file name of the low-level
  1827. *--                                      file specified by <filehandle>
  1828. *--                           MODE,<filehandle>  The privilege of the low-level
  1829. *--                                      file specified by <filehandle>
  1830. *--               cKeyWord2 = see list above ...
  1831. *-------------------------------------------------------------------------------
  1832.  
  1833.    parameters cKeyWord, cKeyWord2
  1834.    private cKey, l2Parms, cStart, cSafety, cTempTxt, nLines, cTmpArray
  1835.  
  1836.    cKey = upper(cKeyWord)
  1837.    l2Parms = (pcount() = 2)
  1838.  
  1839.    do case
  1840.       case cKey = "CTRL-" .or. cKey = "SHIFT" .or. ;
  1841.        (","+cKey+"," $ ",F2,F3,F4,F5,F6,F7,F8,F9,F10,")
  1842.        cStart = cKey + space(9 - len(cKey))+"-"
  1843.  
  1844.       case cKey = "PRINT"
  1845.        cStart = "Print Destination:"
  1846.  
  1847.       case cKey = "WORK"
  1848.        cStart = "Current work area ="
  1849.        if "" <> dbf()
  1850.           RETURN select(alias())
  1851.        endif
  1852.  
  1853.       case cKey = "ERROR"
  1854.        cStart = "On Error:"
  1855.     
  1856.       case cKey = "ESCAPE"
  1857.        cStart = "On Escape:"
  1858.  
  1859.       case cKey = "PAGE"
  1860.        cStart = "On Page At Line"
  1861.  
  1862.       case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1863.        cStart = "Low level files opened"
  1864.  
  1865.       otherwise      && none of the above
  1866.        RETURN ""
  1867.  
  1868.    endcase
  1869.  
  1870.    cSafety = set("SAFETY")
  1871.    cTempTxt = TempFile()
  1872.    *-- get status info (into a temp file), which will then be parsed to extract
  1873.    *-- information requested ...
  1874.    set console off
  1875.    set alternate to &cTempTxt.  && create file without extension
  1876.    set alternate on
  1877.    list status
  1878.    close alternate
  1879.    set console on
  1880.    
  1881.    nLines = TextLine(cTempTxt)
  1882.    aTmpArray = right(cTempTxt,8)
  1883.    cTmp = AAppend(cTempTxt,aTmpArray)
  1884.    nHandle = fopen(cTempTxt,"R")
  1885.    cResult = ""
  1886.  
  1887.    nX = 1
  1888.    do while nX <= nLines
  1889.       if left(&aTmpArray[nX],len(cStart)) = cStart
  1890.      cResult = ltrim(substr(&aTmpArray[nX],len(cStart)+1))
  1891.      exit
  1892.       endif
  1893.       nX = nX + 1
  1894.    enddo
  1895.  
  1896.    *-- 2 parameters?
  1897.    if l2Parms .and. "" # cResult
  1898.       do case
  1899.      case cKey = "PAGE"
  1900.           if upper(cKeyWord2) = "LINE"
  1901.          cResult = left(cResult,at(" ",cResult) - 1)
  1902.           else
  1903.          cResult = substr(cResult,at(" ",cResult) + 1)
  1904.           endif
  1905.  
  1906.      case cKey = "HANDLE" .or. cKey = "NAME" .or. cKey = "MODE"
  1907.           cResult = ""
  1908.           nX = nX + 2
  1909.           do while val(&aTmpArray[nX]) <> 0
  1910.          do case
  1911.             case cKey = "HANDLE" .and. upper(cKeyWord2) $ &aTmpArray[nX]
  1912.              cResult = str(val(&aTmpArray[nX]))
  1913.  
  1914.             case cKey = "NAME" .and. cKeyWord2 = val(&aTmpArray[nX])
  1915.              cResult = substr(&aTmpArray[nX],10,40)
  1916.  
  1917.             case cKey = "MODE" .and. cKeyWord2 = val(&aTmpArray[nX])
  1918.              cResult = substr(&aTmpArray[nX],50,5)
  1919.           endcase
  1920.           if "" <> cResult
  1921.              exit
  1922.           endif
  1923.           nX = nX + 1
  1924.           enddo
  1925.       endcase
  1926.    endif
  1927.  
  1928.    relase &aTmpArray
  1929.    nClose = fclose(nHandle)
  1930.    set safety off
  1931.    erase (cTempTxt)
  1932.    set safety &cSafety
  1933.    cResult = ltrim(rtrim(cResult))
  1934.  
  1935. RETURN iif(right(cResult,1) = ":",;
  1936.       left(cResult,len(cResult-1)),cResult)
  1937. *-- EoF: GetInfo()
  1938.  
  1939. FUNCTION TextLine
  1940. *-------------------------------------------------------------------------------
  1941. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1942. *-- Date........: 04/xx/1992
  1943. *-- Notes.......: Returns the number of lines of text in an ASCII Text File
  1944. *--               Taken from TechNotes, April, 1992
  1945. *-- Written for.: dBASE IV, 1.5
  1946. *-- Rev. History: None
  1947. *-- Calls.......: None
  1948. *-- Called by...: Any
  1949. *-- Usage.......: TextLine(<cTextFile>)
  1950. *-- Example.....: ?TextLine("CONFIG.DB")
  1951. *-- Returns.....: Number of lines
  1952. *-- Parameters..: cTextFile = name of file
  1953. *-------------------------------------------------------------------------------
  1954.  
  1955.    parameter cTextFile
  1956.    private nLines, nHandle, cTemp, nClose
  1957.  
  1958.    nLines = 0
  1959.    if file(cTextFile)   && if it exists ...
  1960.       nHandle = fopen(cTextFile,"R")
  1961.       do while .not. feof(nHandle)
  1962.      cTemp = fgets(nHandle,254)
  1963.      nLines = nLines + 1
  1964.       enddo
  1965.       nClose = fclose(nHandle)
  1966.    endif
  1967.  
  1968. RETURN nLines
  1969. *-- EoF: TextLine()
  1970.  
  1971. FUNCTION TLine
  1972. *-------------------------------------------------------------------------------
  1973. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  1974. *-- Date........: 04/xx/1992
  1975. *-- Notes.......: Returns a specific line in an ASCII Text File. This is similar
  1976. *--               to the way MLINE() works on a memo field. Taken from TechNotes
  1977. *--               April, 1992.
  1978. *-- Written for.: dBASE IV, 1.5
  1979. *-- Rev. History: None
  1980. *-- Calls.......: None
  1981. *-- Called by...: Any
  1982. *-- Usage.......: TLine(<cTextFile>,<nLine>)
  1983. *-- Example.....: ?TLine("CONFIG.DB",20)
  1984. *-- Returns.....: Character expression - specified line of text file.
  1985. *-- Parameters..: cTextFile = name of text file
  1986. *--               nLine     = line to return from text file
  1987. *-------------------------------------------------------------------------------
  1988.  
  1989.    parameters cTextFile, nLine
  1990.    private cText, nX, nHandle, nClose
  1991.  
  1992.    cText = ""
  1993.    nX = 1
  1994.    if file(cTextFile)    && if file exists ...
  1995.       nHandle = fopen(cTextFile,"R")
  1996.       do while .not. feof(nHandle)
  1997.      cText = fgets(nHandle,254)
  1998.      if nX = nLine
  1999.         exit
  2000.      endif
  2001.      nX = nX + 1
  2002.       enddo
  2003.       nClose = fclose(nHandle)
  2004.    endif
  2005.  
  2006. RETURN cText
  2007. *-- EoF: TLine()
  2008.  
  2009. FUNCTION TLineNo
  2010. *-------------------------------------------------------------------------------
  2011. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2012. *-- Date........: 04/xx/1992
  2013. *-- Notes.......: Returns the line number of the phrase you are searching for
  2014. *--               in an ASCII Text File. This is similar to dBASE's AT() 
  2015. *--               function, but works on LINES rather than CHARACTERS.
  2016. *--               Taken from TechNotes, April, 1992
  2017. *-- Written for.: dBASE IV, 1.5
  2018. *-- Rev. History: None
  2019. *-- Calls.......: None
  2020. *-- Called by...: Any
  2021. *-- Usage.......: TLineNo(<cTextFile>,<cLookup>,[<lCase>])
  2022. *-- Example.....: ?TLineNo("CONFIG.DB","command",.f.)
  2023. *-- Returns.....: numeric value (the line number containing the line needed)
  2024. *--               returns -1 if not found
  2025. *-- Parameters..: cTextFile = Name of ASCII Text File
  2026. *--               cLookup   = Text to search for ...
  2027. *--               lCase     = Case Sensitive? (Default is .F.)
  2028. *-------------------------------------------------------------------------------
  2029.  
  2030.    parameters cTextFile, cLookup, lCase
  2031.    private cPhrase, nHandle, cText, nX, nClose
  2032.  
  2033.    if pCount() = 3 .and. lCase
  2034.       lCase = .t.
  2035.       cPhrase = cLookup
  2036.    else
  2037.       lCase = .f.
  2038.       cPhrase = upper(cLookup)
  2039.    endif
  2040.  
  2041.    cText = ""
  2042.    nX = 1
  2043.    if file(cTextFile)
  2044.       nHandle = fopen(cTextFile,"R")
  2045.       do while .not. feof(nHandle)
  2046.      cText = fgets(nHandle,254)
  2047.      if at(cPhrase,iif(lCase,cText,upper(cText))) > 0
  2048.         nClose = fclose(nHandle)
  2049.         RETURN nX
  2050.      endif
  2051.      nX = nX + 1
  2052.       enddo
  2053.  
  2054.       nClose = fclose(nHandle)
  2055.    endif
  2056.  
  2057. RETURN -1
  2058. *-- EoF: TLineNo()
  2059.  
  2060. FUNCTION TempFile
  2061. *-------------------------------------------------------------------------------
  2062. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2063. *-- Date........: 04/xx/1992
  2064. *-- Notes.......: Returns a random filename.
  2065. *-- Written for.: dBASE IV, 1.5
  2066. *-- Rev. History: None
  2067. *-- Calls.......: TempDir()            Function in FILES.PRG
  2068. *-- Called by...: Any
  2069. *-- Usage.......: TempFile([cFileExt])
  2070. *-- Example.....: cVarFile = TempFile("$XY")
  2071. *-- Returns.....: Filename
  2072. *-- Parameters..: cFileExt = optional parameter - allows you to assign a
  2073. *--                          file extension to the end of the filename.
  2074. *-------------------------------------------------------------------------------
  2075.  
  2076.    parameters cFileExt
  2077.  
  2078. RETURN TempDir()+"TMP"+right(ltrim(str(rand(-1)*10000000)),5);
  2079.        +iif(pcount() = 0 .or. "" = cFileExt,"","."+cFileExt)
  2080. *-- EoF: TempFile()
  2081.  
  2082. FUNCTION TempDir
  2083. *-------------------------------------------------------------------------------
  2084. *-- Programmer..: Adam L. Menkes (Borland Technical Support)
  2085. *-- Date........: 04/xx/1992
  2086. *-- Notes.......: Returns path of temporary directory as set from DOS
  2087. *--               (i.e., SET DBTMP= ...) Taken from TechNotes, April, 1992
  2088. *-- Written for.: dBASE IV, 1.5
  2089. *-- Rev. History: None
  2090. *-- Calls.......: GetEnv()             Function in FILES.PRG
  2091. *-- Called by...: Any
  2092. *-- Usage.......: TempDir()
  2093. *-- Example.....: ?TempDir()
  2094. *-- Returns.....: Path of temporary directory
  2095. *-- Parameters..: None
  2096. *-------------------------------------------------------------------------------
  2097.  
  2098.   cTempDir = iif("" <> GetEnv("DBTMP"),GetEnv("DBTMP"),GetEnv("TMP"))
  2099.  
  2100. RETURN cTempDir+iif(right(cTempDir,1)<> "\" .and.;
  2101.      left(os(),3) = "DOS" .and. .not. "" = cTempDir,"\","")
  2102. *-- EoF: TempDir()
  2103.  
  2104. *-------------------------------------------------------------------------------
  2105. *-- EoP: FILES.PRG
  2106. *-------------------------------------------------------------------------------
  2107.